Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/forge20.zip/EXTPROC3.PAS

Pascal/Delphi Source File | 1993-01-04 | 5KB | 192 lines

Procedure Review_Next_Rec;
Begin
  Blank_Fields;
  If Not EOF(Output_File) Then Begin
    Current_File_Pos:= Current_File_Pos+1;
    Read_Record_and_Write_It;
    End
  Else Begin  {it is EOF}
    Sound(1000);
    Delay(200);
    Nosound;
    Current_File_Pos:= FileSize(Output_File)+1;
    Write_Init_Val;
    End;
  Write_Recno;
  End; { procedure review_next_rec }


Procedure Goto_RecNo;

Var
  Key:              Char;
  Goto_File_Pos:    String[6];

Begin
  TextBackground(LightGray);
  TextColor(Black);
  GotoXY(41,25);
  Write('      ');
  GotoXY(41,25);
  Repeat
    Repeat
      Read(Kbd, Key);
    Until Key <> Chr(0);
    If Key in ['0'..'9'] Then Begin
      Goto_File_Pos:= Goto_File_Pos + Key;
      Write(Key);
      End;
  Until Key = Chr(13);
  Val(Goto_File_Pos, Current_File_Pos, ErrorPos);
  If ErrorPos = 0 Then Begin
    If ((Current_File_Pos > 0)
           and not (Current_File_Pos > FileSize(Output_File))) Then Begin
      Read_Record_and_Write_It;
      Write_RecNo;
      End
    Else Begin  {current_file_pos is > filesize}
      Sound(5000);
      Delay(150);
      NoSound;
      Current_File_Pos:= FileSize(Output_File);
      Read_Record_and_Write_It;
      Write_RecNo;
      End;
    End { if errorpos = 0 }
  Else Goto_RecNo;
End; { procedure goto_recno }




Procedure Write_To_Output_File;

Begin
  Seek(Output_File,Current_File_Pos-1);
  Write(Output_File,Output_Record);
  If not EOF(Output_File) Then Begin
    Banner_Line;
    Review_Next_Rec;
    End
  Else Begin  {it is EOF}
    Current_File_Pos:= FilePos(Output_File)+1;
    Banner_Line;
    Write_Recno;
    End;
  End; { procedure write_to_output_file }



Procedure Delete_Rec;

Begin
  If Output_Record.Delete <> 'X' Then
    Output_Record.Delete:= 'X'
  Else Output_Record.Delete:= ' ';
  Write_To_Output_File;
End;


Procedure BackUp;

Var
         EXISTS: Boolean;

Begin
  Close(Output_File);
  i:= 1;
  BackUp_File_Name:= '';
  While ((i < 9) and not (Copy(File_Name,i,1) = '.')) Do Begin
    BackUp_File_Name:= BackUp_File_Name + Copy(File_Name,i,1);
    i:= i+1;
    End;
  BackUp_File_Name:= BackUp_File_Name + '.bak';
  If NOT (Backup_File_Name = File_Name) Then Begin
    Assign(Old_File, Backup_File_Name);       { purge the oldest .bak file  }
    {$I-} Erase(Old_File) {$I+}; EXISTS:= (IOresult = 0); { force continuation }
    Assign(Old_File, File_Name);              { orig. file becomes .bak file }
    Rename(Old_File, Backup_File_Name);
    Assign(New_OutPut_File, File_Name);       { new file gets the orig. name }
    Rewrite(New_OutPut_File);
    Reset(Old_File);
    While not EOF(Old_File) Do Begin
      Read(Old_File, Output_Record);          { copy all records except the  }
      If Output_Record.Delete <> 'X'Then         { deleted ones from the .bak   }
        Write(New_Output_File, Output_Record);   { file to the new file         }
      End;
    Close (New_Output_File);
    Close (Old_File);
    Assign(Output_File, File_Name);
    Reset(Output_File);
    Current_File_Pos:= FileSize(Output_File);
    Blank_Fields;
    Read_Record_and_Write_It;
    Write_RecNo;
    End {if back_up_name <> file_name}
  Else Begin {back_up_name does = file_name}
    Sound (1000);
    Delay (200);
    NoSound;
    GotoXY (2,25); TextColor(Black);
    TextBackGround(LightGray);
    For i:= 1 to 65 Do Write (Chr(32));
    GotoXY (2,25);
    Write ('Cannot Backup ".bak" Files');
    End; {back_up_name does = file_name}
End; { procedure backup }





Procedure ReadKbd;

Var
     Key1, Key         :Char;
     X1, X2            :Byte;

Begin
  Repeat
    X1:= 0;
    X2:= 0;
    Repeat
      Read(Kbd,Key1);
    Until Key1 <> Chr(0);
    X1:= Ord(Key1);
    Key1:= Chr(X1);
    Case X1 of
           27: Begin
               Read(Kbd,Key);
               X2:= Ord(Key);
                 Case X2 of
                     59: Done_Adding:= True;  {f1}
                     60: Review_Prev_Rec;     {f2}
                     61: Review_Next_Rec;     {f3}
                     62: Delete_Rec;          {f4}
                     63: Goto_RecNo;          {f5}
                     66: BackUp;              {f8}
                     77: RT1;                 {rt arrow}
                     75: LT1;                 {lt arrow}
                     {83: Left_Shift_Buffer;}  { del key }
                 End;
               End;
           Else If Key1 = Chr(8) Then  {bs key}
                 Begin
                 LT1;
{                 Left_Shift_Buffer;          }
                 End
           Else If ((Key1 = Chr(9)) or (Key1 = Chr(13))) Then   {tab or ret key}
                 Tab
           Else Begin
                 Write(Key1);
                 ScrBuf[XY]:= Key1;
                 Rt1;
                 End;
    End;
  Until ((Key = Chr(68)) or (Key = Chr(59))); { f0 or f1 key }
Output_Record.Delete:= Chr(32);
Output_Record.CR:= Chr(13);
Done_Reading_Kbd:= True;
End;     { procedure readkbd }